;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;                                                                ;;;
;;;                           cl-famix                             ;;;
;;;                     (Common Lisp FAMIX library)                ;;;
;;;                        by Adrian DOZSA                         ;;;
;;;                                                                ;;;
;;;                      FAMIX Lisp Metamodel                      ;;;
;;;                                                                ;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;


;; cl-famix package
 
(in-package :cl-famix)

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

;; The Model class

(defclass lisp-model ()
  ((elements
    :initform (make-hash-table)
    :accessor elements)
   (name
    :initarg name
    :initform nil
    :accessor name)))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;


;; Interface to accessing model's elements

(defmethod add-element (element (model lisp-model))
  (setf (gethash (id element) (elements model)) element))

(defun get-model-list (model)
  (let ((model-list nil))
    (maphash #'(lambda (id-key element)
                 (values id-key)   ;ignoring value
                 (push element model-list))
             (elements model))
    model-list))

(defun sort-model-list-by-type (model-list)
  (sort model-list
        (lambda (e1 e2)
          (string-lessp (type-of e1)
                        (type-of e2)))))

(defmethod get-element-by-id ((model lisp-model) id)
  (gethash id (elements model)))

(defmethod find-element ((model lisp-model) &key id name type supertype parent)
  (when (or id name type supertype parent)
    (let ((model-list (get-model-list model)))
      (loop for element in model-list
            when (and (if (or id type supertype
                              (and name (has-name element))
                              (and parent (parent element)))
                          t
                        nil)
                      (if (not (null id))
                          (equal id (id element))
                        t)
                      (if (and (not (null name))
                               (has-name element))
                          (equal (if (symbolp name)
                                     (string name)
                                   name)
                                 (if (symbolp (name element))
                                     (string (name element))
                                   (name element)))
                        t)
                      (if (not (null type))
                          (equal (type-of element) type)
                        t)
                      (if (not (null supertype))
                          (subtypep (type-of element) supertype)
                        t)
                      (if (not (null parent))
                          (when (not (null (parent element)))
                            (equal (name (parent element)) parent))
                        t))
            return element))))

(defmethod filter-elements ((model lisp-model) &key id name type supertype parent)
  (when (or id name type supertype parent)
    (let ((filtered-list nil))  
      (maphash #'(lambda (id-key element)
                   (values id-key)   ;ignoring value
                   (when (and (if (or id type supertype
                                      (and name (has-name element))
                                      (and parent (parent element)))
                                  t
                                nil)
                              (if (not (null id))
                                  (equal id (id element))
                                t)
                              (if  (and (not (null name))
                                        (has-name element))
                                  (equal (if (symbolp name)
                                             (string name)
                                           name)
                                         (if (symbolp (name element))
                                             (string (name element))
                                           (name element)))
                                t)
                              (if (not (null type))
                                  (equal (type-of element) type)
                                t)
                              (if (not (null supertype))
                                  (subtypep (type-of element) supertype)
                                t)
                              (if (not (null parent))
                                  (when (not (null (parent element)))
                                    (equal (name (parent element)) parent))
                                t))
                     (push element filtered-list)))
               (elements model))
      filtered-list)))
  
(defmethod delete-by-id ((model lisp-model) id)
  (setf (gethash id (elements model)) nil)) 


(defun find-caller-obj (caller)
  (if (listp caller)
      (find-if #'(lambda (element)
                   (equal (specializedOn element)
                          (second caller)))
               (filter-elements *model*
                                :name (first caller)
                                :type 'FAMIX.Method))
    (or  (find-element *model*
                       :name caller
                       :type 'FAMIX.Macro)
         (find-element *model*
                       :name caller     ;(symbol-name caller)
                       :type 'FAMIX.Function))))
                     ; :package (package-name (symbol-package caller))))

(defun find-fun-callee-obj (callee)
  (find-element *model*
                :name callee     ;(symbol-name caller)
                :supertype 'FAMIX.AbstractCallableEntity))
              ; :package (package-name (symbol-package caller))))

(defun find-var-callee-obj (callee)
  (or  (find-element *model*
                     :name callee
                     :supertype 'FAMIX.AbstractStructuralEntity)))

(defun find-callers (element)
  (loop for invocation in (filter-elements *model*
                                           :type 'FAMIX.Invocation)
        when (and (complete-p invocation)
                  (equal (id element)
                         (id (get-element-by-id *model*
                                                (candidate invocation)))))
        collect (get-element-by-id *model*
                                   (invokedBy invocation))))
 
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;


;; Methods for relations betwen model elements

(defmethod create-references ((model lisp-model))
  (maphash #'(lambda (id-key element)
               (values id-key)   ;ignoring value
               (create-references element))
           (elements model)))

(defmethod create-calls ((model lisp-model))
  (maphash #'(lambda (id-key element)
               (values id-key)   ;ignoring value
               (when (or (subtypep (type-of element) 'FAMIX.AbstractBehaviouralEntity)
                         (subtypep (type-of element) 'FAMIX.AbstractStructuralEntity))
                 (create-calls element)))
           (elements model)))

(defmethod create-expands ((model lisp-model))
  (maphash #'(lambda (id-key element)
               (values id-key)   ;ignoring value
               (when (subtypep (type-of element) 'FAMIX.AbstractTransformationEntity)
                 (create-expands element)))
           (elements model)))

(defmethod calculate-complexity ((model lisp-model))
  (loop for element in (get-model-list model)
        when (subtypep (type-of element) 'FAMIX.AbstractBehaviouralEntity)
        do
        (when (source element)
          (setf (nosexp element) (complexity (source element)))
          (setf (nomesexp element) (complexity (macroexpand (source element)))))))


(defmethod add-default ((model lisp-model))
  ;;default <Object> class
  (let ((element (make-instance 'FAMIX.Class)))
    (setf (name element) 'OBJECT)
    (setf (stub element) "true")
    (setf (belongsTo element) 'COMMON-LISP-USER)
    (add-element element model))
 ;;default <EQL> class
  (let ((element (make-instance 'FAMIX.Class)))
    (setf (name element) 'EQL)
    (setf (stub element) "true")
    (setf (belongsTo element) 'COMMON-LISP-USER)
    (add-element element model))
  ;;default cl-user package
  (let ((element (make-instance 'FAMIX.Namespace)))
    (setf (name element) 'COMMON-LISP-USER)
    (setf (stub element) "true")
    (add-element element *model*)))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;


;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;   FAMIX Lisp Metamodel   ;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;
;; FAMIX Lisp extension clases
;;
;; FAMIX.ModelRoot
;; FAMIX.AbstractObject
;; FAMIX.AbstractNamedEntity
;; FAMIX.AbstractBehaviouralEntity
;; FAMIX.AbstractCallableEntity
;; FAMIX.Function
;; FAMIX.AbstractTransformationEntity
;; FAMIX.Macro
;; FAMIX.Method
;; FAMIX.AbstractScopable
;; FAMIX.Class
;; FAMIX.Namespace
;; FAMIX.AbstractStructuralEntity
;; FAMIX.AbstractLocalEntity
;; FAMIX.LocalVariable
;; FAMIX.FormalParameter
;; FAMIX.GlobalVariable
;; FAMIX.Attribute
;; FAMIX.AbstractFile
;; FAMIX.File
;; FAMIX.Folder
;; FAMIX.Comment
;; FAMIX.AbstractAssociation
;; FAMIX.Access
;; FAMIX.Invocation
;; FAMIX.InheritanceDefinition
;; FAMIX.MacroExpansion
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;


;; CL_FAMIX package
 
(in-package :cl-famix)

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;


;;; The FAMIX Lisp Metamodel calsses

(defclass FAMIX.ModelRoot ()
  ((id
    :initform (new-id-value)
    :reader id
    :initarg id)
   (stub
    :initform "false"
    :accessor stub
    :initarg stub)
   (type-name
    :initform "FAMIX.ModelRoot"
    :reader type-name)))

(defclass FAMIX.AbstractObject (FAMIX.ModelRoot)
  ((comments
    :initform nil
    :accessor comments
    :initarg comments)
   (isExpanded
    :initform "false"
    :accessor isExpanded :accessor is-expanded
    :initarg isExpanded)
   (type-name
    :initform "FAMIX.AbstractObject")))


(defclass FAMIX.AbstractNamedEntity (FAMIX.AbstractObject)
  ((name
    :initarg :name
    :initform nil
    :accessor name
    :initarg name)
   (type-name
    :initform "FAMIX.AbstractNamedEntity")))

(defclass FAMIX.AbstractBehaviouralEntity (FAMIX.AbstractNamedEntity)
  ((belongsTo
    :initform nil
    :accessor belongsTo :accessor belongs-to
    :initarg belongsTo)
   (signature
    :initform nil
    :accessor signature
    :initarg signature)
   (source
    :initform nil
    :accessor source
    :initarg source)
   (nosexp
    :initform 0
    :accessor nosexp
    :initarg nosexp)
   (nomesexp
    :initform 0
    :accessor nomesexp
    :initarg nomesexp)
   (type-name
    :initform "FAMIX.AbstractBehaviouralEntity")))

(defclass FAMIX.AbstractCallableEntity (FAMIX.AbstractBehaviouralEntity)
  ((type-name
    :initform "FAMIX.AbstractCallableEntity")))

(defclass FAMIX.Function (FAMIX.AbstractCallableEntity)
  ((type-name
    :initform "FAMIX.Function")))

(defclass FAMIX.GenericFunction (FAMIX.AbstractCallableEntity)
  ((methodCombination
    :initform nil
    :accessor methodCombination 
    ;; :accessor method-combination - Common Lisp function
    :initarg methodCombination)
   (type-name
    :initform "FAMIX.GenericFunction")))

(defclass FAMIX.Method (FAMIX.AbstractBehaviouralEntity)
  ((specializedOn
    :initform nil
    :accessor specializedOn :accessor specialized-on
    :initarg specializedOn)
   (specializes
    :initform nil
    :accessor specializes
    :initarg specializes)
   (qualifier
    :initform nil
    :accessor qualifier
    :initarg qualifier)  
   (type-name
    :initform "FAMIX.CLOSMethod")))

(defclass FAMIX.AbstractTransformationEntity (FAMIX.AbstractCallableEntity)
  ((type-name
    :initform "FAMIX.AbstractTransformationEntity")))

(defclass FAMIX.Macro (FAMIX.AbstractTransformationEntity)
  ((macroFunction
    :initform nil
    :accessor macroFunction 
    ;; :accessor macro-function - Common Lisp function
    :initarg macroFunction)
   (expandsTo
    :initform nil
    :accessor expandsTo :accessor expand-to
    :initarg expandsTo)
   (type-name
    :initform "FAMIX.Macro")))

(defclass FAMIX.AbstractScopable (FAMIX.AbstractNamedEntity)
  ((belongsTo
    :initform nil
    :accessor belongsTo :accessor belongs-to
    :initarg belongsTo)
   (type-name
    :initform "FAMIX.AbstractScopable")))

(defclass FAMIX.Class (FAMIX.AbstractScopable)
  ((belongsTo
    :initform nil
    :accessor belongsTo :accessor belongs-to
    :initarg belongsTo)
   (metaclass
    :initform nil
    :accessor metaclass
    :initarg metaclass)
   (source
    :initform nil
    :accessor source
    :initarg source)
   (type-name
    :initform "FAMIX.Class")))

(defclass FAMIX.Namespace (FAMIX.AbstractScopable)
  ((uses
    :initform nil
    :accessor uses
    :initarg uses)
   (imports
    :initform nil
    :accessor imports
    :initarg imports)
   (exports
    :initform nil
    :accessor exports
    :initarg exports)
   (type-name
    :initform "FAMIX.Namespace")))

(defclass FAMIX.AbstractStructuralEntity (FAMIX.AbstractNamedEntity)
  ((declaredClass
    :initform nil
    :accessor declaredClass :accessor declared-class
    :initarg declaredClass)
  (declaredType
   :initform nil
   :accessor declaredType :accessor declared-type
   :initarg declaredType)
   (type-name
    :initform "FAMIX.AbstractStructuralEntity")))

(defclass FAMIX.AbstractLocalEntity (FAMIX.AbstractStructuralEntity)
  ((belongsTo
    :initform nil
    :accessor belongsTo :accessor belongs-to
    :initarg belongsTo)
   (type-name
    :initform "FAMIX.AbstractLocalEntity")))

(defclass FAMIX.LocalVariable (FAMIX.AbstractLocalEntity)
  ((type-name
    :initform "FAMIX.LocalVariable")))

(defclass FAMIX.FormalParameter (FAMIX.AbstractLocalEntity)
  ((positionInList
    :initform nil
    :accessor positionInList :accessor position-in-list
    :initarg positionInList)
   (type-name
    :initform "FAMIX.FormalParameter")))

(defclass FAMIX.GlobalVariable (FAMIX.AbstractStructuralEntity)
  ((belongsTo
    :initform nil
    :accessor belongsTo :accessor belongs-to
    :initarg belongsTo)
   (type-name
    :initform "FAMIX.GlobalVariable")))

(defclass FAMIX.Attribute (FAMIX.AbstractStructuralEntity)
  ((hasClassScope
    :initform "false"
    :accessor hasClassScope :accessor has-class-scope
    :initarg hasClassScope)
   (reader
    :initform nil
    :accessor reader
    :initarg reader)
   (writer
    :initform nil
    :accessor writer
    :initarg writer)
   (accessor
    :initform nil
    :accessor accessor
    :initarg accessor)
   (initform
    :initform nil
    :accessor initform
    :initarg initform)
   (belongsTo
    :initform nil
    :accessor belongsTo :accessor belongs-to
    :initarg belongsTo)
   (type-name
    :initform "FAMIX.Attribute")))

(defclass FAMIX.AbstractFile (FAMIX.AbstractNamedEntity)
  ((type-name
    :initform "FAMIX.AbstractFile")))

(defclass FAMIX.File (FAMIX.AbstractFile)
  ((belongsTo
    :initform nil
    :accessor belongsTo :accessor belongs-to
    :initarg belongsTo)
   (type-name
    :initform "FAMIX.File")))

(defclass FAMIX.Folder (FAMIX.AbstractFile)
  ((files
    :initform nil
    :accessor files
    :initarg files)
   (folders
    :initform nil
    :accessor folders
    :initarg folders)
   (belongsTo
    :initform nil
    :accessor belongsTo :accessor belongs-to
    :initarg belongsTo)
   (type-name
    :initform "FAMIX.Folder")))

(defclass FAMIX.Comment (FAMIX.AbstractObject)
  ((content
    :initform nil
    :accessor content
    :initarg content)
   (belongsTo
    :initform nil
    :accessor belongsTo :accessor belongs-to
    :initarg belongsTo)
   (type-name
    :initform "FAMIX.Comment")))

(defclass FAMIX.AbstractAssociation (FAMIX.AbstractObject)
  ((type-name
    :initform "FAMIX.AbstractAssociation")))

(defclass FAMIX.Access (FAMIX.AbstractAssociation)
  ((accesses
    :initform nil
    :accessor accesses
    :initarg accesses)
   (readWriteAccess
    :initform nil
    :accessor readWriteAccess :accessor read-write-access
    :initarg readWriteAccess)
   (accessedIn
    :initform nil
    :accessor accessedIn :accessor accessed-in
    :initarg accessedIn)
   (type-name
    :initform "FAMIX.Access")))

(defclass FAMIX.Invocation (FAMIX.AbstractAssociation)
  ((receivingVariable
    :initform nil
    :accessor receivingVariable :accessor receiving-variable
    :initarg receivingVariable)
   (invokedBy
    :initform nil
    :accessor invokedBy :accessor invoked-by
    :initarg invokedBy)
   (invokes
    :initform nil
    :accessor invokes
    :initarg invokes)
   (candidate
    :initform nil
    :accessor candidate
    :initarg candidate)
   (type-name
    :initform "FAMIX.Invocation")))

(defclass FAMIX.InheritanceDefinition (FAMIX.AbstractAssociation)
  ((subclass
    :initform nil
    :accessor subclass
    :initarg subclass)
   (superclass
    :initform nil
    :accessor superclass
    :initarg superclass)
   (index
    :initform nil
    :accessor index
    :initarg index)
   (type-name
    :initform "FAMIX.InheritanceDefinition")))

(defclass FAMIX.MacroExpansion (FAMIX.AbstractAssociation)
  ((expandsTo
    :initform nil
    :accessor expandsTo :accessor expands-to
    :initarg expandsTo)
   (macro
    :initform nil
    :accessor macro
    :initarg macro)
   (type-name
    :initform "FAMIX.MacroExpansion")))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;


;; Nameble elements

(defmethod has-name ((element FAMIX.ModelRoot))
  nil)

(defmethod has-name ((element FAMIX.AbstractNamedEntity))
  t)

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;


;;; Parsing functions

(defmethod parse-form ((keyword (eql 'defun)) form)
  ;;add function
  (let ((element (make-instance 'FAMIX.Function)))
    (setf (name element) (second form))
    (setf (signature element) (subseq form 1 3))
    (setf (belongsTo element) *current-package*)
    (setf (source element) form)
    (add-element element *model*)
    
    ;;add formal parameters
    (loop for parameter in (third form)
          for position from 0
          until (eql #\& 
                     (char (symbol-name parameter) 0))
          with function-id = (id element)
          do
          (let ((element (make-instance 'FAMIX.FormalParameter)))
            (setf (name element) parameter)
            (setf (belongsTo element) function-id)               
            (setf (positionInList element) position)
            (add-element element *model*)))))

(defmethod parse-form ((keyword (eql 'defclass)) form)
  ;;add class
  (let ((element (make-instance 'FAMIX.Class)))
    (setf (name element) (second form))
    (setf (belongsTo element) *current-package*)
	(setf (source element) form)
    (add-element element *model*))
  ;;add inheritance
  (if (null (third form))
      (let ((element (make-instance 'FAMIX.InheritanceDefinition)))
        (setf (superclass element) 'Object)
        (setf (subclass element) (second form))              
        (setf (index element) 0)
        (add-element element *model*))
    (loop for superclass in (third form)
          for index from 0
          with subclass = (second form)
          do
          (let ((element (make-instance 'FAMIX.InheritanceDefinition)))
            (setf (superclass element) superclass)
            (setf (subclass element) subclass)              
            (setf (index element) index)
            (add-element element *model*))))
  ;;add attributes (slots)
  (loop for attribute-def in (fourth form)
        with class = (second form)                  
        do
        (let ((element (make-instance 'FAMIX.Attribute)))
          (setf (name element) (first attribute-def))
          (setf (belongsTo element) class)
          (let ((allocation-pos (position :allocation attribute-def)))
            (when allocation-pos
              (setf (hasClassScope element) 
                    (if (eql (nth (1+ allocation-pos)
                                  attribute-def) 
                             :class)
                        "true"
                      "false"))))
          (let ((reader-pos (position :reader attribute-def))
                (writer-pos (position :writer attribute-def))
                (accessor-pos (position :accessor attribute-def))
                (initform-pos (position :initform attribute-def)))
            (when reader-pos
              (setf (reader element) (nth (1+ reader-pos) attribute-def)))
            (when writer-pos
              (setf (writer element) (nth (1+ writer-pos) attribute-def)))
            (when accessor-pos
              (setf (accessor element) (nth (1+ accessor-pos) attribute-def)))
            (when initform-pos
              (setf (initform element) (nth (1+ initform-pos) attribute-def))))
          (add-element element *model*)
          
          ; add reader/writer/accessor methods
          ; reader
          (let ((pos (or (position :reader attribute-def)
                         (position :accessor attribute-def))))
            (when pos
              (when (null (find-element *model*
                                       :name (nth (1+ pos) attribute-def)
                                       :type 'FAMIX.GenericFunction))
                (let ((new-generic (make-instance 'FAMIX.GenericFunction)))
                  (setf (name new-generic) (nth (1+ pos) attribute-def))
                  (setf (signature new-generic) (list (name new-generic) (list (name element))))
                  (setf (belongsTo new-generic) *current-package*)
                  (add-element new-generic *model*)))
              
              (let ((new-element (make-instance 'FAMIX.Method)))                  
                (setf (name new-element) (nth (1+ pos) attribute-def))
                (setf (signature new-element) (list (name new-element)
                                                    (list (list 'variable class))))
                (setf (specializedOn new-element) (list class))
                (setf (specializes new-element) (name new-element))
                (setf (belongsTo new-element) *current-package*)
                (add-element new-element *model*)
                ; add the access to the attribute
                (let ((new-access (make-instance 'FAMIX.Access)))
                  (setf (accesses new-access) (id element))
                  (setf (accessedIn new-access) (id new-element))
                  (setf (readWriteAccess new-access) "false")
                  (setf (belongsTo new-element) *current-package*)
                  (add-element new-access *model*)))))
          ;writer
          (let ((pos (or (position :writer attribute-def)
                         (position :accessor attribute-def))))
            (when pos
              (when (null (find-element *model*
                                        :name (list 'setf (nth (1+ pos) attribute-def))
                                        :type 'FAMIX.GenericFunction))
                (let ((new-generic (make-instance 'FAMIX.GenericFunction)))
                  (setf (name new-generic) (list 'setf (nth (1+ pos) attribute-def)))
                  (setf (signature new-generic) (list (list 'setf (name new-generic)) (list (name element))))
                  (setf (belongsTo new-generic) *current-package*)
                  (add-element new-generic *model*)))
              
              (let ((new-element (make-instance 'FAMIX.Method)))                  
                (setf (name new-element) (nth (1+ pos) attribute-def))
                (setf (signature new-element) (list (name new-element)
                                                    (list (list 'variable class))))
                (setf (specializedOn new-element) (list class))
                (setf (specializes new-element) (list 'setf (name new-element)))
                (setf (belongsTo new-element) *current-package*)
                (add-element new-element *model*)
                ; add the access to the attribute
                (let ((new-access (make-instance 'FAMIX.Access)))
                  (setf (accesses new-access) (id element))
                  (setf (accessedIn new-access) (id new-element))
                  (setf (readWriteAccess new-access) "true")
                  (setf (belongsTo new-element) *current-package*)
                  (add-element new-access *model*))))))))
         
(defmethod parse-form ((keyword (eql 'defgeneric)) form)
  ;;add generic function
  (let ((element (make-instance 'FAMIX.GenericFunction)))
    (setf (name element) (second form))
    (setf (signature element) (subseq form 1 3))
    (setf (belongsTo element) *current-package*)
    (setf (source element) form)
    (setf (methodCombination element)
          (second          
           (find-if (lambda (elem)
                      (and (listp elem)
                           (equal (first elem) 
                                  :method-combination)))
                    form)))
    (add-element element *model*)))

(defmethod parse-form ((keyword (eql 'defmethod)) form)
  ;;add method
  (let ((element (make-instance 'FAMIX.Method)))
    (setf (name element) (second form))
    (setf (signature element) (subseq form 1 
                                      (if (listp (third form))
                                          3
                                        4)))
    (let* ((param-def-list (if (listp (third form))
                               (third form)
                             (fourth form)))
           (class-list (get-method-specialization-list param-def-list)))
      (if class-list
          (setf (specializedOn element) class-list)
        (setf (specializedOn element) (list 'Object))))
    (setf (specializes element) (second form))
    (when (not (listp (third form)))
      (setf (qualifier element) (third form)))
    (setf (belongsTo element) *current-package*)
    (setf (source element) form)
    (add-element element *model*)
    
    ;;add formal parameters
    (loop for parameter in (if (listp (third form))
                               (third form)
                             (fourth form))
          for position from 0
          until (and (atom parameter)
                     (eql #\& 
                          (char (symbol-name parameter) 0)))    
          with method-id = (id element)
          do
          (let ((element (make-instance 'FAMIX.FormalParameter))
                (name (if (listp parameter)
                          (first parameter)
                        parameter)))
            (setf (name element) name)
            (setf (belongsTo element) method-id)               
            (setf (positionInList element) position)
            (when (and (listp parameter)
                       (not (listp (second parameter)))) 
              (setf (declaredClass element) (second parameter)))
            (add-element element *model*))))
    
  ;;add generic method (if doesn't exists) !!!This sould be done after scanning the source code
  (when (null (find-element *model*
                            :name (second form)
                            :type 'FAMIX.GenericFunction))
    (let* ((param-list (if (listp (third form))
                           (third form)
                         (fourth form)))
           (new-param-list  (mapcar (lambda (el)
                                      (if (listp el)
                                          (first el)
                                        el))
                                    param-list))
           (new-form (list 'defgeneric
                           (second form)
                           new-param-list)))
      (parse-form (first new-form) new-form))))

(defmethod parse-form ((keyword (eql 'defpackage)) form)
  ;;add package
  (when (null (find-element *model*
                            :name (second form)
                            :type 'FAMIX.Namespace))
    (let ((element (make-instance 'FAMIX.Namespace))
          (uses (find-if (lambda (elem)
                           (and (listp elem)
                                (equal (first elem)
                                       :use)))
                         form))
          (exports (find-if (lambda (elem)
                              (and (listp elem)
                                   (equal (first elem)
                                          :export)))
                            form))
          (imports (find-if (lambda (elem)
                              (and (listp elem)
                                   (equal (first elem)
                                          :import)))
                            form)))
      (setf (name element) (second form))
      (setf (uses element) (rest uses))
      (setf (exports element) (rest exports))
      (setf (imports element) (rest imports))
      (add-element element *model*))))
  
(defmethod parse-form ((keyword (eql 'defconstant)) form)
  ;;add global variable
  (let ((element (make-instance 'FAMIX.GlobalVariable)))
    (setf (name element) (second form))
    (setf (belongsTo element) *current-package*)
    (add-element element *model*)))

(defmethod parse-form ((keyword (eql 'defparameter)) form)
  ;;add global variable
  (let ((element (make-instance 'FAMIX.GlobalVariable)))
    (setf (name element) (second form))
    (setf (belongsTo element) *current-package*)
    (add-element element *model*)))

(defmethod parse-form ((keyword (eql 'defvar)) form)
  ;;add global variable
  (let ((element (make-instance 'FAMIX.GlobalVariable)))
    (setf (name element) (second form))
    (setf (belongsTo element) *current-package*)
    (add-element element *model*)))

(defmethod parse-form ((keyword (eql 'setq)) form)
  ;;add global variable
  (when (null (find-element *model* 
                            :name (second form)
                            :type 'FAMIX.GlobalVariable))
    (let ((element (make-instance 'FAMIX.GlobalVariable)))
      (setf (name element) (second form))
      (setf (belongsTo element) *current-package*)
      (add-element element *model*))))

(defmethod parse-form ((keyword (eql 'setf)) form)
  ;;add global variable
  (when (atom (second form))
    (when (null (find-element *model* 
                              :name (second form) 
                              :type 'FAMIX.GlobalVariable))
      (let ((element (make-instance 'FAMIX.GlobalVariable)))
        (setf (name element) (second form))
        (setf (belongsTo element) *current-package*)
        (add-element element *model*)))))

(defmethod parse-form ((keyword (eql 'defmacro)) form)
  ;;add macro  
  (let ((element (make-instance 'FAMIX.Macro)))
    (setf (name element) (second form))
    (setf (signature element) (subseq form 1 3))
    (setf (belongsTo element) *current-package*)
    (setf (macroFunction element) (subseq form 3))
    (setf (source element) form)
    (add-element element *model*)
    
    ;;add formal parameters
    (loop for parameter in (third form)
          for position from 0
          until (and (symbolp parameter)
                     (eql #\& 
                          (char (symbol-name parameter) 0)))
          with macro-id = (id element)
          when (symbolp parameter)
          do
          (when (symbolp parameter)
            (let ((element (make-instance 'FAMIX.FormalParameter)))
              (setf (name element) parameter)
              (setf (belongsTo element) macro-id)               
              (setf (positionInList element) position)
              (add-element element *model*))))))

(defmethod parse-form ((keyword (eql 'in-package)) form)
  (when (null (find-element *model*
                            :name (if (keywordp (second form))
                                      (symbol-name (second form))
                                    (second form))
                            :type 'FAMIX.Namespace))
    (let ((element (make-instance 'FAMIX.Namespace)))
      (setf (name element) (second form))
      (add-element element *model*)))
  (setf *current-package* (second form)))

;default method
(defmethod parse-form (keyword form)
  ;; other entities
  nil)

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;


;;; Filesystem entites 

(defun add-file (file)
  (let ((element (make-instance 'FAMIX.File)))
    (setf (name element) (file-name file))
    (setf (belongsTo element) 
          (first (reverse (pathname-directory file))))
    (add-element element *model*)))

(defun add-folder (folder)
  (let ((element (make-instance 'FAMIX.Folder)))
    (setf (name element) 
          (first (reverse (pathname-directory folder))))
    (setf (belongsTo element)
          (second (reverse (pathname-directory folder))))
    (add-element element *model*)))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;


;;; Creating references between objects after parsing

(defmethod create-references ((element FAMIX.ModelRoot))
  )

(defmethod create-references :after ((element FAMIX.AbstractObject))
  )

(defmethod create-references :after ((element FAMIX.AbstractNamedEntity))
  )

(defmethod create-references :after ((element FAMIX.AbstractBehaviouralEntity))
  (when (belongsTo element)
    (let ((namespace (or (find-element *model*
                                       :name (belongsTo element)
                                       :type 'FAMIX.Namespace)
                         (find-element *model*
                                       :name 'COMMON-LISP-USER
                                       :type 'FAMIX.Namespace))))  
      (setf (belongsTo element) 
            (if namespace 
                (id namespace)
              nil)))))

(defmethod create-references :after ((element FAMIX.AbstractCallableEntity))
  )

(defmethod create-references :after ((element FAMIX.Function))
  )

(defmethod create-references :after ((element FAMIX.Method))
  (when (specializedOn element)
    (setf (specializedOn element)
          (loop for class-name in (specializedOn element)
                for class = (find-element *model*
                                          :name class-name
                                          :type 'FAMIX.Class)
                when class
                collect (id class))))
  (when (specializes element)
    (let ((function (find-element *model*
                                  :name (specializes element)
                                  :type 'FAMIX.GenericFunction)))  
      (setf (specializes element) 
            (if function 
                (id function)
              nil)))))

(defmethod create-references :after ((element FAMIX.AbstractTransformationEntity))
  )

(defmethod create-references :after ((element FAMIX.Macro))
  )

(defmethod create-references :after ((element FAMIX.AbstractScopable))
  )

(defmethod create-references :after ((element FAMIX.Class))
  (when  (belongsTo element)
    (let ((namespace (or (find-element *model*
                                       :name (belongsTo element)
                                       :type 'FAMIX.Namespace)
                         (find-element *model*
                                       :name 'COMMON-LISP-USER
                                       :type 'FAMIX.Namespace))))
      (setf (belongsTo element) 
            (if namespace 
                (id namespace)
              nil)))))
                    
(defmethod create-references :after ((element FAMIX.Namespace))
  (when (uses element)
    (setf (uses element)
          (loop for name in (uses element)
                for namespace = (find-element *model*
                                              :name name
                                              :type 'FAMIX.Namespace)
                when namespace
                collect (id namespace))))
  (when (imports element)
    (setf (imports element)
          (loop for name in (imports element)
                for entity = (find-element *model*
                                           :name name
                                           :supertype 'FAMIX.AbstractBehaviouralEntity)
              when entity
              collect (id entity))))
  (when (exports element)
    (setf (exports element)
          (loop for name in (exports element)
                for entity = (find-element *model*
                                           :name name
                                           :supertype 'FAMIX.AbstractBehaviouralEntity)
                when entity
                collect (id entity)))))

(defmethod create-references :after ((element FAMIX.AbstractStructuralEntity))
  (when (declaredClass element)
    (let ((class (find-element *model*
                               :name (declaredClass element)
                               :type 'FAMIX.Class)))
      (setf (declaredClass element)
            (if class
                (id class)
              nil)))))

(defmethod create-references :after ((element FAMIX.AbstractLocalEntity))
  )

(defmethod create-references :after ((element FAMIX.LocalVariable))
  )

(defmethod create-references :after ((element FAMIX.FormalParameter))
  )

(defmethod create-references :after ((element FAMIX.GlobalVariable))
  (when (belongsTo element)
    (let ((namespace (or (find-element *model*
                                       :name (belongsTo element)
                                       :type 'FAMIX.Namespace)
                         (find-element *model*
                                       :name 'COMMON-LISP-USER
                                       :type 'FAMIX.Namespace)))) 
      (setf (belongsTo element) 
            (if namespace 
                (id namespace)
              nil)))))

(defmethod create-references :after ((element FAMIX.Attribute))
  (when (belongsTo element)
    (let ((class (find-element *model*
                               :name (belongsTo element)
                               :type 'FAMIX.Class)))
      (setf (belongsTo element) 
            (if class
                (id class)
              nil)))))

(defmethod create-references :after ((element FAMIX.AbstractFile))
  )

(defmethod create-references :after ((element FAMIX.File))
  (when (belongsTo element)
    (let ((folder (find-element *model*
                                :name (belongsTo element)
                                :type 'FAMIX.Folder)))
      (setf (belongsTo element) 
            (if folder
                (id folder)
              nil)))))

(defmethod create-references :after ((element FAMIX.Folder))
  (when (belongsTo element)
    (let ((folder (find-element *model*
                                :name (belongsTo element)
                                :type 'FAMIX.Folder)))
      (setf (belongsTo element) 
            (if folder
                (id folder)
              nil)))))  

(defmethod create-references :after ((element FAMIX.Comment))
  )

(defmethod create-references :after ((element FAMIX.AbstractAssociation))
  )

(defmethod create-references :after ((element FAMIX.Access))
  )

(defmethod create-references :after ((element FAMIX.Invocation))
  )

(defmethod create-references :after ((element FAMIX.InheritanceDefinition))
  (when (superclass element) 
    (let ((class (or (find-element *model*
                                   :name (superclass element)
                                   :type 'FAMIX.Class)
                     (let ((new-class (make-instance 'FAMIX.Class)))
                       (setf (stub new-class) "true")
                       (setf (name new-class) (superclass element))
                       (setf (belongsTo new-class) 
                             (id (find-element *model*
                                               :name 'COMMON-LISP-USER
                                               :type 'FAMIX.Namespace)))
                       (add-element new-class *model*)
                       new-class))))
      (setf (superclass element) (id class))))
  
  (when (subclass element)
    (let ((class (find-element *model*
                               :name (subclass element)
                               :type 'FAMIX.Class)))
      (setf (subclass element) 
            (if class 
                (id class)
              nil)))))

(defmethod create-references :after ((element FAMIX.MAcroExpansion))
  )

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;


;;; Create Invocations and Accesses

(defmethod create-calls ((element FAMIX.AbstractBehaviouralEntity))
  ;;default
  )

(defmethod create-calls ((element FAMIX.Function))
  (loop for caller in (xref:list-callers (name element))
        for caller-obj = (find-caller-obj caller)
        when caller-obj
        do
        (let ((new-element (make-instance 'FAMIX.Invocation)))
          (setf (invokedBy new-element) (id caller-obj))
          (setf (candidate new-element) (id element))
          (setf (invokes new-element) (name element))
          (add-element new-element *model*))))     

(defmethod create-calls ((element FAMIX.GenericFunction))
  (loop for caller in (xref:list-callers (name element))
        for caller-obj = (find-caller-obj caller)
        when caller-obj
        do
        (let ((new-element (make-instance 'FAMIX.Invocation)))
          (setf (invokedBy new-element) (id caller-obj))
          (setf (candidate new-element) (id element))
          (setf (invokes new-element) (name element))
          (add-element new-element *model*))))

(defmethod create-calls ((element FAMIX.Method))
  ;same as function (?)
  (loop for caller in (xref:list-callers (name element))
        for caller-obj = (find-caller-obj caller)             
        when caller-obj
        do
        (let ((new-element (make-instance 'FAMIX.Invocation)))
          (setf (invokedBy new-element) (id caller-obj))
          (setf (candidate new-element) (id element))
          (setf (invokes new-element) (name element))
          (add-element new-element *model*))))

(defmethod create-calls ((element FAMIX.Macro))
  (loop for caller in (xref:list-callers (name element))
        for caller-obj = (find-caller-obj caller)     
        when caller-obj
        do
        (let ((new-element (make-instance 'FAMIX.Invocation)))
          (setf (invokedBy new-element) (id caller-obj))
          (setf (candidate new-element) (id element))
          (setf (invokes new-element) (name element))
          (add-element new-element *model*))))

(defmethod create-calls ((element FAMIX.AbstractStructuralEntity))
  ;default
  )

(defmethod create-calls ((element FAMIX.GlobalVariable))
  (loop for setter in (xref:list-setters (name element))
        for setter-obj = (find-caller-obj setter)        
        when setter-obj
        do
        (let ((new-element (make-instance 'FAMIX.Access)))
          (setf (accesses new-element) (id element))
          (setf (accessedIn new-element) (id setter-obj))
          (setf (readWriteAccess new-element) "false")
          (add-element new-element *model*)))
  (loop for reader in (xref:list-readers (name element))
        for reader-obj = (find-caller-obj reader)     
        when reader-obj
        do
        (let ((new-element (make-instance 'FAMIX.Access)))
          (setf (accesses new-element) (id element))
          (setf (accessedIn new-element) (id reader-obj))
          (setf (readWriteAccess new-element) "true")
          (add-element new-element *model*))))

(defmethod create-calls ((element FAMIX.Attribute))
  (loop for caller in (xref:list-callers (name element))
        for caller-obj = (find-caller-obj caller)      
        when caller-obj
        do     
        (let ((new-element (make-instance 'FAMIX.Access)))
          (setf (accesses new-element) (id element))
          (setf (accessedIn new-element) (id caller-obj))
          (setf (readWriteAccess new-element) 
                (if (member caller (xref:list-setters (name element)))
                    "false" ;write
                  "true"))  ;read
          (add-element new-element *model*))))

(defmethod create-calls ((element FAMIX.FormalParameter))
  (let ((parent (get-element-by-id *model* (belongsTo element))))
    (when parent
      (when (member (name parent) (xref:list-setters (name element)))
        (let ((new-element (make-instance 'FAMIX.Access)))
          (setf (accesses new-element) (id element))
          (setf (accessedIn new-element) (id parent))
          (setf (readWriteAccess new-element) "false")
          (add-element new-element *model*)))
      (when (member (name parent) (xref:list-readers (name element)))
        (let ((new-element (make-instance 'FAMIX.Access)))
          (setf (accesses new-element) (id element))
          (setf (accessedIn new-element) (id parent))
          (setf (readWriteAccess new-element) "true")
          (add-element new-element *model*))))))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;


;;; Create macro expansions

(defmethod create-expands ((element FAMIX.Macro))
  (let ((new-fun-callees (remove-if #'null
                                    (mapcar #'find-fun-callee-obj
                                            (gethash (name element) *macro-expand-table*))))
        (new-var-callees (remove-if #'null
                                    (mapcar #'find-var-callee-obj
                                            (gethash (name element) *macro-expand-table*))))
        (callers (find-callers element)))
    
    (loop for caller in callers
          do
          (loop for callee in new-fun-callees
                do                
                (let ((new-element (make-instance 'FAMIX.Invocation)))
                  (setf (invokedBy new-element) (id caller))
                  (setf (candidate new-element) (id callee))
                  (setf (invokes new-element) (name element))
                  (setf (isExpanded new-element) "true")
                  (add-element new-element *model*)

                  (let ((new-expansion (make-instance 'FAMIX.MacroExpansion)))
                    (setf (expandsTo new-expansion) (id new-element))
                    (setf (macro new-expansion) (id element))
                    (add-element new-expansion *model*))))
                
          (loop for callee in new-var-callees
                do                               
                (let ((new-element (make-instance 'FAMIX.Access)))
                  (setf (accessedIn new-element) (id caller))
                  (setf (accesses new-element) (id callee))
                  (setf (readWriteAccess new-element)
                        (if (member (name element) (xref:list-setters (name callee)))
                            "false"
                          "true"))
                  ; need special test for slots...
                  (setf (isExpanded new-element) "true")
                  (add-element new-element *model*)

                  (let ((new-expansion (make-instance 'FAMIX.MacroExpansion)))
                    (setf (expandsTo new-expansion) (id new-element))
                    (setf (macro new-expansion) (id element))
                    (add-element new-expansion *model*)))))))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;


;;; Test for objects completness

(defgeneric complete-p (element)
  (:method-combination AND))

(defmethod complete-p and ((element FAMIX.ModelRoot))
  (and (id element)
       (stub element)))

(defmethod complete-p and ((element FAMIX.AbstractObject))
  t)

(defmethod complete-p and ((element FAMIX.AbstractNamedEntity))
  (name element))

(defmethod complete-p and ((element FAMIX.AbstractBehaviouralEntity))
  t)

(defmethod complete-p and ((element FAMIX.AbstractCallableEntity))
  t)

(defmethod complete-p and ((element FAMIX.Function))
  t)

(defmethod complete-p and ((element FAMIX.GenericFunction))
  t)

(defmethod complete-p and ((element FAMIX.Method))
  (and (specializedOn element)
       (specializes element)))

(defmethod complete-p and ((element FAMIX.AbstractTransformationEntity))
  t)

(defmethod complete-p and ((element FAMIX.Macro))
  (macroFunction element))

(defmethod complete-p and ((element FAMIX.AbstractScopable))
  t)

(defmethod complete-p and ((element FAMIX.Class))
  t)

(defmethod complete-p and ((element FAMIX.Namespace))
  t)

(defmethod complete-p and ((element FAMIX.AbstractStructuralEntity))
  t)

(defmethod complete-p and ((element FAMIX.AbstractLocalEntity))
  (not-null (belongsTo element)))

(defmethod complete-p and ((element FAMIX.LocalVariable))
  t)

(defmethod complete-p and ((element FAMIX.FormalParameter))
  (positionInList element))

(defmethod complete-p and ((element FAMIX.GlobalVariable))
  t)

(defmethod complete-p and ((element FAMIX.Attribute))
  (and (belongsTo element)
       (hasClassScope element)))

(defmethod complete-p and ((element FAMIX.AbstractFile))
  t)

(defmethod complete-p and ((element FAMIX.File))
  t)

(defmethod complete-p and ((element FAMIX.Folder))
  t)

(defmethod complete-p and ((element FAMIX.Comment))
  (and (content element)
       (belongsTo element)))

(defmethod complete-p and ((element FAMIX.AbstractAssociation))
  t)

(defmethod complete-p and ((element FAMIX.Access))
  (and (accesses element)
       (readWriteAccess element)
       (accessedIn element)))

(defmethod complete-p and ((element FAMIX.Invocation))
  (and (invokedBy element)
       (candidate element)))

(defmethod complete-p and ((element FAMIX.InheritanceDefinition))
  (and (subclass element)
       (superclass element)
       (index element)))

(defmethod complete-p and ((element FAMIX.MacroExpansion))
  (and (expandsTo element)
       (macro element)))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;


;; Parent functions - for browsing through entities (depends on entity type)

; default method
(defmethod parent ((element FAMIX.ModelRoot))
  nil)

(defmethod parent ((element FAMIX.AbstractBehaviouralEntity))
  (belongsTo element))

(defmethod parent ((element FAMIX.AbstractScopable))
  (belongsTo element))

(defmethod parent ((element FAMIX.AbstractStructuralEntity))
  (belongsTo element))

(defmethod parent ((element FAMIX.AbstractFile))
  (belongsTo element))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;